home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
pascal
/
bbskt30a.zip
/
HOST.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-11-10
|
15KB
|
563 lines
{
Host.Pas
A sample host BBS for BBSkit.
Version 1.2, updated for BBSkit 3.0.
Written by Steve Madsen.
NOTE: intended to be compiled using the registered version of BBSkit. If
you wish to recompile with a demo copy, remove the space before the $ in
the following $DEFINE.
}
{ $DEFINE DEMO}
{$X+,V-}
PROGRAM Host12;
{$DEFINE NOBSP}
Uses DOS, CRT, BBSkit, Comm, Util, Protocol, MTask;
Const
Version = '1.2';
Type
THost = object(TBBS)
Password : String[20];
ChatReason : String[40];
InChat : Boolean;
PromptSt : String[80];
CONSTRUCTOR Init;
PROCEDURE Run; VIRTUAL;
DESTRUCTOR Done; VIRTUAL;
FUNCTION Chat : Boolean;
FUNCTION HandleVirtualKey(Code : Char) : Boolean; VIRTUAL;
PROCEDURE UserSession;
FUNCTION Menu : Boolean;
PROCEDURE ListFiles;
PROCEDURE ShowFile;
PROCEDURE Upload;
PROCEDURE Download;
PROCEDURE ChatRequest;
end;
Var
Host : THost;
{********************************************************************}
{
* PROCEDURE GetScreenStr
*
* Gets a string of text (no attributes) from the screen and stores
* it in Strn.
}
PROCEDURE GetScreenStr(X, Y, Len : Byte; var Strn : String);
Var
Idx : Byte;
Ch : Char;
Attr : Byte;
begin
Strn := '';
for Idx := X to X + Len - 1 do
begin
GetScreenWord(Idx, Y, Ch, Attr);
Strn := Strn + Ch;
end;
end;
{--------------------------------------------------------------------}
PROCEDURE Usage;
begin
WriteLn;
WriteLn('Host usage:');
WriteLn;
WriteLn('HOST <comport> <baudrate>');
WriteLn;
WriteLn(' <comport> can be 1, 2, 3 or 4.');
WriteLn(' <baudrate> can be 300, 1200, 2400, 4800, 9600, 19200 or 38400.');
WriteLn;
WriteLn('example: HOST 2 2400 { com2, at 2400bps }');
WriteLn(' HOST 1 9600 { com1, at 9600bps }');
end;
{--------------------------------------------------------------------}
CONSTRUCTOR THost.Init;
Var
Ch : Char;
begin
TBBS.Init;
if (not Exist('FILES')) then
begin
vcWriteLn('');
vcWriteLn('Subdirectory "FILES" not found.');
vcWriteLn('');
vcWrite('Create or quit program? (C/Q): ');
Repeat
Ch := UpCase(ReadKey);
Until (Ch = 'C') or (Ch = 'Q');
if (Ch = 'C') then
begin
vcWriteLn('Create');
MkDir('FILES');
end
else
begin
vcWriteLn('Quit');
Halt(1);
end;
end;
OpenPort(StrToInt(ParamStr(1)));
SetAnswerMode(Answer);
SetOutput(True, False);
SetInput(True, False);
SetFlowControl(PortIdx, True, False);
ClearIntChars;
AddIntChar(' ');
SetVirtualKeys(True);
ClearVirtualKeys;
AddVirtualKey(#46); { alt-C, chat enter/exit }
vcWriteLn('');
vcWrite('Today''s password: ');
ComReadLn(Password, 20);
Password := Upper(Password);
ChatReason := '';
InChat := False;
end;
{--------------------------------------------------------------------}
PROCEDURE THost.Run;
Var
Quit : Boolean;
begin
Quit := False;
ClrScr;
while (not Quit) do
begin
SetBpsRate(PortIdx, StrToInt(ParamStr(2)));
vcWriteLn('');
vcWriteLn('Host: Waiting For Call [SPC] for local login [Q] to quit');
while (not LineRinging(PortIdx)) and (not Keypressed) do ;
if (Keypressed) then
begin
case UpCase(ReadKey) of
' ' : begin
SetInput(True, False);
SetOutput(True, False);
UserSession;
end;
'Q' : Quit := True;
end;
end
else
begin
PickupPhone;
if (WaitFor('C', 30)) then ;
if (Carrier(PortIdx)) then
begin
SetOutput(True, True);
SetInput(True, True);
UserSession;
end;
end;
end;
end;
{--------------------------------------------------------------------}
DESTRUCTOR THost.Done;
begin
ClosePort(True);
TBBS.Done;
end;
{--------------------------------------------------------------------}
FUNCTION THost.Chat : Boolean; { chat with user }
Var
St : String;
Wrap : String;
begin
if (not InChat) then
begin
InChat := True;
ChatReason := '';
PromptSt := '';
GetScreenStr(1, WhereY, WhereX - 1, PromptSt);
ComWriteLn('');
ComWriteLn('');
ComWrite('Sysop has entered chat mode.');
vcWrite(' (Sysop: Alt-C to exit)');
ComWriteLn('');
ComWriteLn('');
Wrap := '';
while (InChat) do
ComReadLnWrap(St, 79, Wrap);
Chat := False;
end
else
begin
InChat := False;
ComWriteLn('');
ComWriteLn('');
ComWriteLn('Sysop has exited chat mode.');
ComWriteLn('');
ComWrite(PromptSt);
Chat := True;
end;
end;
{--------------------------------------------------------------------}
FUNCTION THost.HandleVirtualKey(Code : Char) : Boolean;
begin
case Code of
#46 : HandleVirtualKey := Chat;
end;
end;
{--------------------------------------------------------------------}
PROCEDURE THost.UserSession;
Var
Pass : String[20];
Try : Byte;
begin
SetLF(True);
ComWriteLn('');
ComWriteLn('BBSkit Host v' + Version);
Try := 0;
Pass := '';
while (Try < 4) and (Pass <> Password) do
begin
Inc(Try);
ComWriteLn('');
ComWrite('Password: ');
SetEcho('*');
ComReadLn(Pass, 20);
SetEcho(#0);
Pass := Upper(Pass);
ComWriteLn('');
if (Pass <> Password) then ComWriteLn('Incorrect.');
end;
if (Pass = Password) then
begin
ComWriteLn('');
ComWriteLn('Welcome to BBSkit Host.');
ComWriteLn('');
while (Menu) do ;
end;
Hangup;
end;
{--------------------------------------------------------------------}
FUNCTION THost.Menu : Boolean;
Var
Cmd : Char;
begin
Menu := True;
vcWrite('Sysop: Alt-C enters chat mode');
if (ChatReason <> '') then
vcWrite(' WANTS CHAT: ' + ChatReason);
vcWriteLn('');
ComWrite('[L]ist files [T]ype file [U]pload [D]ownload [C]hat [G]oodbye: ');
Cmd := UpCase(ComReadKey);
ComWriteLn(Cmd);
case Cmd of
'L' : ListFiles;
'T' : ShowFile;
'U' : Upload;
'D' : Download;
'C' : ChatRequest;
'G' : begin
ComWriteLn('');
ComWrite('Sure? ');
Repeat
Cmd := UpCase(ComReadKey);
Until (Cmd = 'Y') or (Cmd = 'N');
ComWriteLn(Cmd);
if (Cmd = 'Y') then
begin
Menu := False;
ComWriteLn('');
ComWriteLn('Goodbye...');
end;
ComWriteLn('');
end;
end;
end;
{--------------------------------------------------------------------}
PROCEDURE THost.ListFiles;
Var
FInfo : SearchRec;
FTime : DateTime;
Name : String[8];
Ext : String[3];
begin
ComWriteLn('');
ComWriteLn('Listing of all available files:');
ComWriteLn('');
FindFirst('FILES\*.*', Archive OR ReadOnly, FInfo);
while (DOSError = 0) do
begin
Name := Copy(FInfo.Name, 1, Pos('.', FInfo.Name) - 1);
Ext := Copy(FInfo.Name, Pos('.', FInfo.Name) + 1, 3);
UnpackTime(FInfo.Time, FTime);
ComWrite(Left(Name, 8) + '.' + Left(Ext, 3) + ' ');
ComWrite(Right(IntToStr(FInfo.Size), 7) + ' bytes ');
if (FTime.Hour < 10) then ComWrite('0');
ComWrite(IntToStr(FTime.Hour) + ':');
if (FTime.Min < 10) then ComWrite('0');
ComWriteLn(IntToStr(FTime.Min));
FindNext(FInfo);
end;
ComWriteLn('');
end;
{--------------------------------------------------------------------}
PROCEDURE THost.ShowFile;
Var
Fname : String[12];